
#|_______________________
 |
 | OBJECT NAME FUNCTIONS
 |_______________________
 |#



(defun make-names (pathname &optional extension)
"ARGS: STATPATHNAME EXTENSION
Makes ViSta statistical object names from the strings STATPATHNAME and EXTENSION. Uses and updates *vista* sob-name list for unique version number. Returns seven element list with elements that are the strings name, full-name, proper-name, elipsis-name, nickname and version number string and the integer version number. If NAME is not a ViSta statistical object pathname, the fifth element is NAME."
  (let* ((proper-pathname (proper-name pathname extension))
         (namelist (parse-name proper-pathname))
         (name (first namelist))
         (version (get-proper-name-version name extension))
         (version-integer version)
         (version (if (= version 1) " " (format nil "~a" version)))
         (proper-name (strcat (first namelist) "." 
                              (if (equal version " ") 
                                  (second namelist) 
                                  (strcat (second namelist) "#" version))))
         (full-name (if (equal version " ")
                        (first namelist)
                        (strcat (first namelist) "#" version)))
         (elipsis-name (elipsis-name proper-name))
         (nickname (nickname proper-name))
       ; (dataflow-path 
       ;  (mapcar #'(lambda (step) 
       ;              (setf dataflow-path (strcat step "»" dataflow-path)))
       ;          (fourth namelist)))
       ; (dataflow-name (strcat "[" name "]»" (first (last dataflow-path)) "[" proper-name "]"))
       ; (result (list name full-name proper-name elipsis-name dataflow-name))
         (result (list name full-name proper-name elipsis-name nickname 
                       version version-integer))
         )
    (send *vista* :sob-names (append (send *vista* :sob-names) (list (strcat name "." extension))))
    result))


(defun ancestors (sob &optional str)
  (let* ((parents (send sob :dob-parents))
         (parent))
    (cond
     (parents        
      (setf str (if (equal str nil) 
                    (strcat " » " (nickname (send sob :proper-name)))
                    (strcat " » " str)))
      (dotimes (j (length parents))
               (setf parent (select parents j))
               (setf str (strcat (nickname (send parent :proper-name)) str))
               (print str)
               (ancestors parent str)))
      (t str))))


(defun dataflow-name (proper-name)
  (let* ((namelist (parse-name proper-name)))
    (strcat "["
            (first namelist) 
            "." 
            (second namelist) 
            "#"
            (format nil "~a" (third namelist))
            "]"
            (dataflow-path proper-name)
            )))


(defun dataflow-path (proper-name)
  (mapcar #'(lambda (step) 
              (setf path (strcat path "»" step )))
          (fourth (parse-name proper-name))))


(defun parse-dataflow-path (dataflow-path)
  (let* ((L! (position #\! (reverse dataflow-path) :test #'equal))
         (L! (if L! (- (length dataflow-path) 1 L!) 0))
         (path (cond ((> L! 0) (select dataflow-path (iseq L!))) (t nil)))
         (name (cond ((> L! 0) (subseq dataflow-path (1+ L!))) (t dataflow-path)))
         )
    (list path name)))



(defun get-full-name (name)
  (third (get-sob-name name)))

(defun proper-name (name &optional (ext nil ext?) (ver 1 ver?))
"Args: name &contionally-optional datatype-extension &optional version-number
Object is a string or an object, datatype-extension is a string, and version is a number. If object is a string, then datatype-extension is required. It may be nil, but must be specified as such.. If name is a string, it is optional and can be nil. In either case, version-number is optional, defaulting to 1."

  (let ((dt))
    (cond
      ((objectp name)
       (setf dt (datatype? name))
       (setf name (send name :name))
       (setf ext (if ext ext (third dt))))
      ((stringp name)
       (unless ext? 
               (error "Extension must be specified when name is a string. It may be specified as being nil. If name is an object, extension need not be specified")))
      (T
       ))
    (setf ver (if ver? ver (get-proper-name-version (strcat name "." ext))))
    (strcat  name "." ext "#" (format nil "~a" ver))))

(defun parse-name (name)
"parses proper vista object names of the form \"pathstep1!pathstep2!name.ext#ver\" returning list with four elements. The elements are the name (a string), extension (a string), version (an integer), and a list of strings of the steps in the dataflow path. The above would return (\"name\" \"ext\" ver (\"pathstep1\" \"pathstep2\")"
  (let* ((full-name (string name))
         (name (remove-period full-name))
         (L. (position #\. full-name :test #'equal))
         (L# (position #\# full-name :test #'equal))
       
         (ext (cond
                ((and L. L#)
                 (subseq full-name (1+ L.) L#))
                (L.
                 (subseq full-name (1+ L.)))
                (t nil)))
         (ver (cond
                (L# (read-from-string (subseq full-name (1+ L#))))
                (t nil)))
         (name (if (position #\# name :test #'equal)
                   (select name (iseq (position #\# name :test #'equal)))
                   name))
         (path-name name)
         (path+name (parse-dataflow-path path-name))
         (path nil)
         (name (second path+name))
         )
    (loop 
     (cond
       ((first path+name) 
        (setf path+name (parse-dataflow-path (first path+name)))
        (setf path (append path (list (second path+name)))))
       (t
        (return))))
    (list name ext ver path)))


(defun get-proper-name-version (name &optional extension)
  (let* ((implied-name (if extension (strcat name "." extension) name))
         (names (intersection (list implied-name )
                                (send *vista* :sob-names)
                                :test #'equal)))
    (1+ (length names))))

(defun concatenate-version (name &optional extension)
  (let* ((implied-name (if extension (strcat name "." extension) name))
         (version (third (get-sob-extension implied-name))))
    (format nil "~a#~a" implied-name version)))

(defun parse-sob-name (name)
"Args: name
(see help for (parse-name))
Used for old style, two-level names of the form name.ver 
Parses old-style vista object names into name and extension, WHERE EXTENSION MEANS VERSION IN PROPER NAMES, and the proper-name concept of extension wasn't used. returns 3 element list of full-name, name and extension (which is nil if omitted). The first two are strings, the last a number."
  (let* ((full-name (string name))
         (name (remove-period full-name))
         (ext))
    (when (not (equal name full-name))
          (setf ext (read-from-string  (subseq full-name 
               (1+ (position #\. full-name :test #'equal))))))
    (list full-name name ext)))

(defun get-sob-extension (name &optional dont-increment)
"Args: name
Used for old style, two-level names of the form name.ver 
Adds an extension (which is a string made from the proper-name version number) to name. The number is one more than the count of the number of other objects with the same name."
  (unless dont-increment
          (send *vista* :sob-names (append (send *vista* :sob-names) (list name))))
    (let* ((names (intersection (list name )
                                (send *vista* :sob-names)
                                :test #'equal))
           (extension (length names))
           (pading (cond ((< extension 10) "00")((< extension 100) "0")
                         ((< extension 999) "") ((> 999)(error "too many files"))))
           (fullname (strcat (string name) "." (format nil "~a~a" pading extension)))
           (fullname (if (< extension 2)
                         (string name)
                         (strcat (string name) "#" (format nil "~a" extension))))
           )
      (list fullname name extension)))
    
(defun elipsis-name (proper-name)
  (let* ((names (parse-name proper-name))
         (name   proper-name)
         (name  (cond 
                  ((not (third names)) name)
                  ((= (third names) 1)
                   (select name (iseq (- (length name) 2))))
                  (t name)))
         (lname (length name))
         (str   (cond
                  ((not (third names)) nil)
                  ((= (third names) 1) nil)
                  (t (strcat "#" (format nil "~a" (third names))))))
         (str   (if str (strcat "~." (second names) str) (strcat "~." (second names))))
         (lstr  (length str))
         (max-length-str 12)
         )
    (if ;(> (length proper-name) max-length-str);changed fwy 09-09-02
        (> lname max-length-str)
        (strcat (select name (iseq (min (- max-length-str lstr) lname))) str)
        name)
    ))

(defun nickname (proper-name)
  (let* ((name (parse-name proper-name))
         (nickname (strcat (first name) "." (second name)))
         (version (third name)))
    (cond
      ((not version) nickname)
      ((= 1 version)   nickname)
      (t (format nil "~a#~d" nickname version)))))


(defun trimmed-name (name)
  (let* ((backname (reverse name)))
    (if (equal (select backname (iseq 2)) "1#")
        (select name (iseq (- (length name) 2)))
        name)))